home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / kits / gambit / hash.scm < prev    next >
Text File  |  1992-09-23  |  5KB  |  171 lines
  1. ; -*-Scheme-*-
  2. ;
  3. ; $Id: gambit_hash.scm,v 1.2 1992/09/23 15:24:00 birkholz Exp $
  4. ; $MIT-Header: prop1d.scm,v 14.4 89/09/15 17:16:35 GMT jinx Exp $
  5. ;
  6. ; Copyright (c) 1988, 1989 Massachusetts Institute of Technology
  7. ;
  8. ; This material was developed by the Scheme project at the Massachusetts
  9. ; Institute of Technology, Department of Electrical Engineering and
  10. ; Computer Science.  Permission to copy this software, to redistribute
  11. ; it, and to use it for any purpose is granted, subject to the following
  12. ; restrictions and understandings.
  13. ;
  14. ; 1. Any copy made of this software must include this copyright notice
  15. ; in full.
  16. ;
  17. ; 2. Users of this software agree to make their best efforts (a) to
  18. ; return to the MIT Scheme project any improvements or extensions that
  19. ; they make, so that these may be included in future releases; and (b)
  20. ; to inform MIT of noteworthy uses of this software.
  21. ; 
  22. ; 3. All materials developed as a consequence of the use of this
  23. ; software shall duly acknowledge such use, in accordance with the usual
  24. ; standards of acknowledging credit in academic research.
  25. ;
  26. ; 4. MIT has made no warrantee or representation that the operation of
  27. ; this software will be error-free, and MIT is under no obligation to
  28. ; provide any services, by way of maintenance, update, or otherwise.
  29. ;
  30. ; 5. In conjunction with products arising from the use of this material,
  31. ; there shall be no use of the name of the Massachusetts Institute of
  32. ; Technology nor of any adaptation thereof in any advertising,
  33. ; promotional, or sales literature without prior written consent from
  34. ; MIT in each case.
  35.  
  36. ; This file requires the following non-IEEE primitives:
  37.  
  38. ; ##weak-cons, ##weak-car, ##weak-cdr, ##weak-set-cdr! for manipulating
  39. ; "weak-cons cells," whose cdr is normal but whose car turns to #F
  40. ; during a garbage collection if no non-weak references are found to
  41. ; the object in the car.
  42.  
  43. ; ##gc-finalize registers a thunk (procedure of no arguments) to be called
  44. ; after each garbage collection is complete and before Scheme resumes
  45. ; running.
  46.  
  47. ;;;; One Dimensional Property Tables
  48.  
  49. (define (initialize-oned-table-package!)
  50.   (set! population-of-oned-tables (make-population)))
  51.  
  52. (define population-of-oned-tables #f)
  53.  
  54. (define (gc-oned-tables!)
  55.   (map-over-population! population-of-oned-tables oned-table/clean!))
  56.  
  57. (define (make-oned-table)
  58.   (let ((table (list oned-table-tag)))
  59.     (add-to-population! population-of-oned-tables table)
  60.     table))
  61.  
  62. (define (oned-table? object)
  63.   (and (pair? object)
  64.        (eq? (car object) oned-table-tag)))
  65.  
  66. (define oned-table-tag
  67.   "1D table")
  68.  
  69. (define false-key
  70.   "false key")
  71.  
  72. (define (weak-assq key table)
  73.   (let loop ((previous table) (alist (cdr table)))
  74.     (and (not (null? alist))
  75.      (let ((entry (car alist))
  76.            (next (cdr alist)))
  77.        (let ((key* (##weak-car entry)))
  78.          (cond ((not key*)
  79.             (set-cdr! previous next)
  80.             (loop previous next))
  81.            ((eq? key* key)
  82.             entry)
  83.            (else
  84.             (loop alist next))))))))
  85.  
  86. (define (oned-table/get table key default)
  87.   (let ((entry (weak-assq (or key false-key) table)))
  88.     (if entry
  89.     (##weak-cdr entry)
  90.     default)))
  91.  
  92. (define (oned-table/lookup table key if-found if-not-found)
  93.   (let ((entry (weak-assq (or key false-key) table)))
  94.     (if entry
  95.     (if-found (##weak-cdr entry))
  96.     (if-not-found))))
  97.  
  98. (define (oned-table/put! table key value)
  99.   (let ((key (or key false-key)))
  100.     (let ((entry (weak-assq key table)))
  101.       (if entry
  102.       (##weak-set-cdr! entry value)
  103.       (set-cdr! table
  104.             (cons (##weak-cons key value)
  105.               (cdr table))))
  106.       #f)))
  107.  
  108. (define (oned-table/remove! table key)
  109.   (let ((key (or key false-key)))
  110.     (let loop ((previous table) (alist (cdr table)))
  111.       (if (not (null? alist))
  112.       (let ((key* (##weak-car (car alist)))
  113.         (next (cdr alist)))
  114.         (loop (if (or (not key*) (eq? key* key))
  115.               ;; Might as well clean whole list.
  116.               (begin
  117.             (set-cdr! previous next)
  118.             previous)
  119.               alist)
  120.           next))))))
  121.  
  122. (define (oned-table/clean! table)
  123.   (let loop ((previous table) (alist (cdr table)))
  124.     (if (not (null? alist))
  125.     (let ((next (cdr alist)))
  126.       (loop (if (##weak-car (car alist))
  127.             alist
  128.             (begin
  129.               (set-cdr! previous next)
  130.               previous))
  131.         next)))))
  132.  
  133. (define (oned-table/alist table)
  134.   (let loop ((previous table) (alist (cdr table)) (result '()))
  135.     (if (null? alist)
  136.     result
  137.     (let ((entry (car alist))
  138.           (next (cdr alist)))
  139.       (let ((key (##weak-car entry)))
  140.         (if (not key)
  141.         (begin
  142.           (set-cdr! previous next)
  143.           (loop previous next result))
  144.         (loop alist
  145.               next
  146.               (cons (cons (and (not (eq? key false-key)) key)
  147.                   (##weak-cdr entry))
  148.                 result))))))))
  149.  
  150. (define (oned-table/for-each proc table)
  151.   (let loop ((previous table) (alist (cdr table)))
  152.     (if (not (null? alist))
  153.     (let ((entry (car alist))
  154.           (next (cdr alist)))
  155.       (let ((key (##weak-car entry)))
  156.         (if key
  157.         (begin
  158.           (proc (and (not (eq? key false-key)) key)
  159.             (##weak-cdr entry))
  160.           (loop alist next))
  161.         (begin
  162.           (set-cdr! previous next)
  163.           (loop previous next))))))))
  164.  
  165. (initialize-oned-table-package!)
  166.  
  167. (set! ##gc-finalize ; setup GC finalization for populations and 1d tables
  168.   (lambda ()
  169.     (gc-all-populations!)
  170.     (gc-oned-tables!)))
  171.